(cl:in-package #:cmp)

(defparameter *additional-clasp-character-mappings-alist*
  `(("NULL"   . #.(code-char 0))
    ("NUL"    . #.(code-char 0))
    ("SOH"    . #.(code-char 1))
    ("STX"    . #.(code-char 2))
    ("ETX"    . #.(code-char 3))
    ("EOT"    . #.(code-char 4))
    ("ENQ"    . #.(code-char 5))
    ("ACK"    . #.(code-char 6))
    ("BELL"   . #.(code-char 7))
    ("BEL"    . #.(code-char 7))
    ("BS"     . #.(code-char 8))
    ("HT"     . #.(code-char 9))
    ("LF"     . #.(code-char 10)) 
    ("VT"     . #.(code-char 11))
    ("FF"     . #.(code-char 12))
    ("CR"     . #.(code-char 13))
    ("SO"     . #.(code-char 14))
    ("SI"     . #.(code-char 15))
    ("DLE"    . #.(code-char 16))
    ("DC1"    . #.(code-char 17))
    ("DC2"    . #.(code-char 18))
    ("DC3"    . #.(code-char 19))
    ("DC4"    . #.(code-char 20))
    ("NAK"    . #.(code-char 21))
    ("SYN"    . #.(code-char 22))
    ("ETB"    . #.(code-char 23))
    ("CAN"    . #.(code-char 24))
    ("EM"     . #.(code-char 25))
    ("SUB"    . #.(code-char 26))
    ("ESCAPE" . #.(code-char 27))
    ("ESC"    . #.(code-char 27))
    ("FS"     . #.(code-char 28))
    ("GS"     . #.(code-char 29))
    ("RS"     . #.(code-char 30))
    ("US"     . #.(code-char 31))
    ("SP"     . #.(code-char 32))
    ("EXCLAMATION_MARK" . #.(code-char 33))
    ("QUOTATION_MARK" . #.(code-char 34))
    ("NUMBER_SIGN" . #.(code-char 35)) 
    ("DOLLAR_SIGN" . #.(code-char 36))
    ("PERCENT_SIGN" . #.(code-char 37)) 
    ("AMPERSAND" . #.(code-char 38))
    ("APOSTROPHE" . #.(code-char 39)) 
    ("LEFT_PARENTHESIS" . #.(code-char 40))
    ("RIGHT_PARENTHESIS" . #.(code-char 41)) 
    ("ASTERISK" . #.(code-char 42))
    ("PLUS_SIGN" . #.(code-char 43)) 
    ("COMMA" . #.(code-char 44))
    ("HYPHEN-MINUS" . #.(code-char 45))
    ("FULL_STOP" . #.(code-char 46))
    ("SOLIDUS" . #.(code-char 47))
    ("DIGIT_ZERO" . #.(code-char 48))
    ("DIGIT_ONE" . #.(code-char 49))
    ("DIGIT_TWO" . #.(code-char 50))
    ("DIGIT_THREE" . #.(code-char 51))
    ("DIGIT_FOUR" . #.(code-char 52))
    ("DIGIT_FIVE" . #.(code-char 53)) 
    ("DIGIT_SIX" . #.(code-char 54))
    ("DIGIT_SEVEN" . #.(code-char 55)) 
    ("DIGIT_EIGHT" . #.(code-char 56))
    ("DIGIT_NINE" . #.(code-char 57)) 
    ("COLON" . #.(code-char 58))
    ("SEMICOLON" . #.(code-char 59)) 
    ("LESS-THAN_SIGN" . #.(code-char 60))
    ("EQUALS_SIGN" . #.(code-char 61)) 
    ("GREATER-THAN_SIGN" . #.(code-char 62))
    ("QUESTION_MARK" . #.(code-char 63)) 
    ("COMMERCIAL_AT" . #.(code-char 64))
    ("LATIN_CAPITAL_LETTER_A" . #.(code-char 65))
    ("LATIN_CAPITAL_LETTER_B" . #.(code-char 66))
    ("LATIN_CAPITAL_LETTER_C" . #.(code-char 67))
    ("LATIN_CAPITAL_LETTER_D" . #.(code-char 68))
    ("LATIN_CAPITAL_LETTER_E" . #.(code-char 69))
    ("LATIN_CAPITAL_LETTER_F" . #.(code-char 70))
    ("LATIN_CAPITAL_LETTER_G" . #.(code-char 71))
    ("LATIN_CAPITAL_LETTER_H" . #.(code-char 72))
    ("LATIN_CAPITAL_LETTER_I" . #.(code-char 73))
    ("LATIN_CAPITAL_LETTER_J" . #.(code-char 74))
    ("LATIN_CAPITAL_LETTER_K" . #.(code-char 75))
    ("LATIN_CAPITAL_LETTER_L" . #.(code-char 76))
    ("LATIN_CAPITAL_LETTER_M" . #.(code-char 77))
    ("LATIN_CAPITAL_LETTER_N" . #.(code-char 78))
    ("LATIN_CAPITAL_LETTER_O" . #.(code-char 79))
    ("LATIN_CAPITAL_LETTER_P" . #.(code-char 80))
    ("LATIN_CAPITAL_LETTER_Q" . #.(code-char 81))
    ("LATIN_CAPITAL_LETTER_R" . #.(code-char 82))
    ("LATIN_CAPITAL_LETTER_S" . #.(code-char 83))
    ("LATIN_CAPITAL_LETTER_T" . #.(code-char 84))
    ("LATIN_CAPITAL_LETTER_U" . #.(code-char 85))
    ("LATIN_CAPITAL_LETTER_V" . #.(code-char 86))
    ("LATIN_CAPITAL_LETTER_W" . #.(code-char 87))
    ("LATIN_CAPITAL_LETTER_X" . #.(code-char 88))
    ("LATIN_CAPITAL_LETTER_Y" . #.(code-char 89))
    ("LATIN_CAPITAL_LETTER_Z" . #.(code-char 90))
    ("LEFT_SQUARE_BRACKET" . #.(code-char 91))
    ("REVERSE_SOLIDUS" . #.(code-char 92))
    ("RIGHT_SQUARE_BRACKET" . #.(code-char 93))
    ("CIRCUMFLEX_ACCENT" . #.(code-char 94))
    ("LOW_LINE" . #.(code-char 95))
    ("GRAVE_ACCENT" . #.(code-char 96))
    ("LATIN_SMALL_LETTER_A" . #.(code-char 97))
    ("LATIN_SMALL_LETTER_B" . #.(code-char 98))
    ("LATIN_SMALL_LETTER_C" . #.(code-char 99))
    ("LATIN_SMALL_LETTER_D" . #.(code-char 100))
    ("LATIN_SMALL_LETTER_E" . #.(code-char 101))
    ("LATIN_SMALL_LETTER_F" . #.(code-char 102))
    ("LATIN_SMALL_LETTER_G" . #.(code-char 103))
    ("LATIN_SMALL_LETTER_H" . #.(code-char 104))
    ("LATIN_SMALL_LETTER_I" . #.(code-char 105))
    ("LATIN_SMALL_LETTER_J" . #.(code-char 106))
    ("LATIN_SMALL_LETTER_K" . #.(code-char 107))
    ("LATIN_SMALL_LETTER_L" . #.(code-char 108))
    ("LATIN_SMALL_LETTER_M" . #.(code-char 109))
    ("LATIN_SMALL_LETTER_N" . #.(code-char 110))
    ("LATIN_SMALL_LETTER_O" . #.(code-char 111))
    ("LATIN_SMALL_LETTER_P" . #.(code-char 112))
    ("LATIN_SMALL_LETTER_Q" . #.(code-char 113))
    ("LATIN_SMALL_LETTER_R" . #.(code-char 114))
    ("LATIN_SMALL_LETTER_S" . #.(code-char 115))
    ("LATIN_SMALL_LETTER_T" . #.(code-char 116))
    ("LATIN_SMALL_LETTER_U" . #.(code-char 117))
    ("LATIN_SMALL_LETTER_V" . #.(code-char 118))
    ("LATIN_SMALL_LETTER_W" . #.(code-char 119))
    ("LATIN_SMALL_LETTER_X" . #.(code-char 120))
    ("LATIN_SMALL_LETTER_Y" . #.(code-char 121))
    ("LATIN_SMALL_LETTER_Z" . #.(code-char 122))
    ("LEFT_CURLY_BRACKET" . #.(code-char 123))
    ("VERTICAL_LINE" . #.(code-char 124))
    ("RIGHT_CURLY_BRACKET" . #.(code-char 125)) 
    ("TILDE" . #.(code-char 126))
    ("DEL"    . #.(code-char 127))))

(defparameter *additional-clasp-character-names*
  (alexandria:alist-hash-table *additional-clasp-character-mappings-alist*
                               :test 'equalp))

(defun simple-unicode-name (name)
  "If NAME is a string from \"U00\" to \"U10FFFF\", return the corresponding Unicode character."
  (if (and (>= (length name) 3) (char-equal (char name 0) #\U))
      (let ((number (parse-integer name :start 1 :radix 16 :junk-allowed t)))
        (if (and (numberp number) (<= #X00 number #X10FFFF))
            (code-char number)
            nil))
      nil))

(defparameter *unicode-file-read* nil)

(defparameter *mapping-char-code-to-char-names*
  (make-hash-table :size (* 1024 32)))

(defun note-mapping-code (code name)
  (setf (gethash name *additional-clasp-character-names*)
        (code-char code))
  (setf (gethash (code-char code) *mapping-char-code-to-char-names*) name))

(defun note-mapping-char (char name)
  (setf (gethash name *additional-clasp-character-names*) char)
  (setf (gethash char *mapping-char-code-to-char-names*) name))

(defun map-char-to-char-name (char)
  (gethash char *mapping-char-code-to-char-names*))

(defun process-unicode-file ()
  (with-open-file (stream #P"sys:tools-for-build;character-names.sexp"
                   :element-type 'character :direction :input :external-format :utf-8)
    (loop for (code . name) in (read stream nil)
          when (>= code #xA0)
            do (note-mapping-code code name)))
  (setq *unicode-file-read* t))

(defun minimal-unicode-name (char)
  (let ((code (char-code char)))
    (format nil "U~x" code)))

(defun process-low-mappings ()
  ;;; now need to store the mappings for the chars with code < #XA0
  (dolist (pair *additional-clasp-character-mappings-alist*)
    (note-mapping-char (cdr pair)(car pair)))
  ;;; assure the offical names from clhs
  (dolist (pair '(("Backspace" . #.(code-char 8))
                  ("Tab"       . #.(code-char 9))
                  ("Newline"   . #.(code-char 10))
                  ("Page"      . #.(code-char 12))
                  ("Return"    . #.(code-char 13))
                  ("Space"     . #.(code-char 32))
                  ("Rubout"    . #.(code-char 127))))
    (setf (gethash (cdr pair) *mapping-char-code-to-char-names*)
          (car pair))
    (setf (gethash (car pair) *additional-clasp-character-names*)
          (cdr pair))))

(defun ensure-unicode-table-loaded ()
  (unless *unicode-file-read*
    (process-unicode-file)
    (process-low-mappings)))
    
(defun cl:name-char (string-designator)
  (let ((name (etypecase string-designator
                (string string-designator)
                (symbol (symbol-name string-designator))
                (character (string string-designator)))))
    (eclector.reader:find-character *cst-client* name)))

(defun cl:char-name (char)
  (or 
   (values (map-char-to-char-name char))
   ;;; If there is no mapping, at least return "U<char-code-as-hex>"
   ;;; Should be the exception
   (minimal-unicode-name char)))

(eval-when (:compile-toplevel)
  (ensure-unicode-table-loaded))

(setq *unicode-file-read* #.*unicode-file-read*)
(setq *additional-clasp-character-names* #.*additional-clasp-character-names*)
(setq *mapping-char-code-to-char-names* #.*mapping-char-code-to-char-names*)
